home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / bbs / tdk_v136.zip / DIGIBORD.PAS < prev    next >
Pascal/Delphi Source File  |  1996-12-26  |  8KB  |  382 lines
  1. {
  2.  ▀▀▀▀▀▀▀▀  ▀▀▀▀▀▀    ▀▀   ▀▀
  3.    ▀▀     ▀▀   ▀▀   ▀▀  ▀▀
  4.   ▀▀     ▀▀   ▀▀▀  ▀▀▀▀▀  The DoorKit!
  5.  ▀▀     ▀▀   ▀▀   ▀▀  ▀▀
  6. ▀▀     ▀▀▀▀▀▀    ▀▀    ▀▀
  7. The BBS Door Development Kit By The People - For The People!
  8.  
  9.  
  10.    Feel free to modify or optimize this code at will. All I ask is that if
  11.    find a better way to do things (and you will), please send me a copy of
  12.    your modifications. Thanks in advance!....Larry L. Athey....}
  13.  
  14. {$A+,B-,D+,E+,F+,G+,I-,L+,N-,O+,P-,Q-,R-,S-,T-,V+,X+}
  15. UNIT DIGIBORD;
  16.  
  17. INTERFACE
  18.  
  19. USES DOS;
  20.  
  21. TYPE
  22.   Idarray = ARRAY[1..8] OF CHAR;
  23.  
  24. VAR
  25.   AsyncStat : WORD;
  26.   dport_num : INTEGER;
  27.   nameptr   : ^idarray;
  28.   OutReady  : BOOLEAN;
  29.  
  30. FUNCTION  Digi_Init_Driver : BOOLEAN;
  31. FUNCTION  Digi_Deinit_Driver : BOOLEAN;
  32. FUNCTION  Digi_Buffer_Check : BOOLEAN;
  33. PROCEDURE Digi_Send(C : CHAR);
  34. FUNCTION  Digi_Receive(VAR C : CHAR) : BOOLEAN;
  35. FUNCTION  Digi_Carrier_Present : BOOLEAN;
  36. PROCEDURE Digi_Set_Modem;
  37. FUNCTION  Digi_Set_Baud(N : LONGINT ; WordSize : BYTE ; Parity : CHAR ; StopBits : BYTE) : BOOLEAN;
  38. PROCEDURE Digi_Flush_IO;
  39. PROCEDURE Digi_Flush_Input;
  40. PROCEDURE Digi_Flush_Output;
  41. PROCEDURE Digi_Get_Info(VAR DriverName : STRING);
  42. PROCEDURE EnableTimeOutError;
  43. PROCEDURE Digi_Break(StatusCode : WORD);
  44.  
  45. IMPLEMENTATION
  46.  
  47. CONST
  48.   dtrmask = 1;
  49.   rtsmask = 2;
  50.  
  51. TYPE
  52.   BytePtr = ^BYTE;
  53.  
  54. VAR
  55.   EBIOSok,DTRok,RTSok    : BOOLEAN;
  56.   CharReadyP : BytePtr;
  57.  
  58. FUNCTION digi_Init_driver : BOOLEAN;
  59. VAR
  60.  regs : REGISTERS;
  61. BEGIN;
  62.  WITH regs DO                         { Get Channel Parameters }
  63.    BEGIN
  64.      ah := $0C;
  65.      dx := dport_num;
  66.    END;
  67.  INTR($14,regs);
  68.  IF regs.ah = $FF THEN
  69.    digi_init_driver := FALSE
  70.  ELSE
  71.    digi_init_driver := TRUE;
  72.                                   { Checks for extended Bios }
  73.  asm
  74.    mov ah,$F4
  75.    mov al,$00
  76.    mov dx,dport_num
  77.    INT $14
  78.  END;
  79.  IF regs.ax = $000 THEN
  80.    EbiosOk := TRUE
  81.  ELSE
  82.    EbiosOk := FALSE;
  83.  
  84.  WITH regs DO                         { checks modem dtr/rts status }
  85.    BEGIN
  86.      ah := $05;
  87.      al := $00;
  88.      dx := dport_num;
  89.    END;
  90.  INTR($14,regs);
  91.  IF (regs.bl AND DTRmask) <> $00 THEN
  92.    DTRok := TRUE
  93.  ELSE
  94.    DTRok := FALSE;
  95.  IF (regs.bl AND RTSmask) <> $00 THEN
  96.    RTSok := TRUE
  97.  ELSE
  98.    RTSok := FALSE;
  99.  
  100.  OutReady := FALSE;
  101. END;
  102.  
  103. FUNCTION  digi_deinit_driver;  { A do nada routine, no deinit calls exist. }
  104. BEGIN
  105.  digi_deinit_driver := TRUE;
  106. END;
  107.  
  108. FUNCTION digi_buffer_check : BOOLEAN;
  109. VAR
  110.  regs : REGISTERS;
  111. BEGIN;
  112.  WITH regs DO
  113.    BEGIN
  114.      ah := $03;
  115.      dx := dport_num;
  116.    END;
  117.  INTR($14,regs);
  118.  IF (regs.ah AND $01) <> $00 THEN   { data ready bit               }
  119.    digi_buffer_check := TRUE        { checks if byte ready to send }
  120.  ELSE
  121.    digi_buffer_check := FALSE;
  122. END;
  123.  
  124. PROCEDURE digi_send(c : CHAR);
  125. VAR
  126.  regs : REGISTERS;
  127. BEGIN;
  128.  WITH regs DO
  129.   BEGIN
  130.     ah := $01;
  131.     al := BYTE(c);
  132.     dx := dport_num;
  133.   END;
  134.  INTR($14,regs);
  135.                                { bit 5 set on = buffer space avail }
  136.  IF (regs.ah AND $20) <> $00 THEN
  137.    OutReady := TRUE
  138.  ELSE
  139.    OutReady := FALSE;
  140. END;
  141.  
  142. FUNCTION digi_receive(VAR c : CHAR) : BOOLEAN;
  143. VAR
  144.  regs : REGISTERS;
  145. BEGIN;
  146.  c := #0;
  147.  digi_receive := FALSE;
  148.  IF digi_buffer_check THEN
  149.   BEGIN
  150.     WITH regs DO
  151.     BEGIN
  152.       ah := $02;
  153.       dx := dport_num;
  154.     END;
  155.     INTR($14,regs);
  156.     IF (regs.ah AND $8E) = $00 THEN
  157.       BEGIN
  158.         c := CHR(regs.al);
  159.         digi_receive := TRUE;
  160.       END;
  161.   END;
  162. END;
  163.  
  164. FUNCTION digi_carrier_present : BOOLEAN;
  165. VAR
  166.  regs : REGISTERS;
  167. BEGIN;
  168.  WITH regs DO
  169.    BEGIN
  170.      ah := $03;
  171.      dx := dport_num;
  172.    END;
  173.  INTR($14,regs);
  174.  IF (regs.al AND $80) <> $00 THEN      { carrier present bit }
  175.    digi_carrier_present := TRUE
  176.  ELSE
  177.    digi_carrier_present := FALSE;
  178.  IF (regs.ah AND $20) <> $00 THEN      { bit 5 set on = buffer space avail }
  179.    OutReady := TRUE                    { thus can check if out buffer ready}
  180.  ELSE
  181.    OutReady := FALSE;
  182. END;
  183.  
  184. FUNCTION ExtBaud(n : LONGINT) : BYTE;
  185. VAR
  186.  b : BYTE;
  187.  w : WORD;
  188. BEGIN
  189.  b := $00;
  190.  w := n;
  191.  
  192.  IF n > 76800 THEN   { 115200 }
  193.    b := $0C
  194.  ELSE
  195.  IF n > 57600 THEN   {  76800 }
  196.    b := $0B
  197.  ELSE
  198.    CASE w OF
  199.      300  : b := $02;
  200.      600  : b := $03;
  201.      1200 : b := $04;
  202.      1800 : b := $11;
  203.      2400 : b := $05;
  204.      4800 : b := $06;
  205.      4801..9600 :  b := $07;
  206.      9601..19200 :  b := $08;
  207.      19201..38400 : b := $09;
  208.      38401..57600 : b := $0A;
  209.    END;
  210.   ExtBaud := b;
  211. END;
  212.  
  213. PROCEDURE digi_set_modem;
  214. VAR
  215.   regs : REGISTERS;
  216. BEGIN
  217.   WITH regs DO
  218.    BEGIN
  219.      dx := dport_num;
  220.      ah := $05;
  221.      al := $01;
  222.      IF dtrok THEN bl := bl OR dtrmask;
  223.      IF rtsok THEN bl := bl OR rtsmask;
  224.    END;
  225.   INTR($14,regs);
  226. END;
  227.  
  228. { This is included for completeness only }
  229. { Most sysops don't want a door to reinitiallize their board }
  230. { so this is by passed.                                      }
  231. FUNCTION digi_set_baud;      { new form digiboard init }
  232. VAR
  233.   regs : REGISTERS;
  234. BEGIN;
  235.  
  236.   WITH regs DO
  237.    BEGIN
  238.      ah := $04;
  239.      al := $00;
  240.      dx := dport_num;
  241.      CASE parity OF
  242.       'N' : bh := $00;
  243.       'O' : bh := $01;
  244.       'E' : bh := $02;
  245.      END;                  {0 = none/ 1 = odd / 2 = even }
  246.      CASE stopbits OF
  247.        1 : bl := $00;
  248.        2 : bl := $01;
  249.      END;
  250.      CASE wordsize OF
  251.        5 : ch := $00;
  252.        6 : ch := $01;
  253.        7 : ch := $02;
  254.        8 : ch := $03;
  255.      END;
  256.      cl := ExtBaud(n);      { set baud rate }
  257.   END;
  258.   INTR($14,regs);
  259.   IF regs.ah = $FF THEN
  260.     digi_set_baud := FALSE
  261.   ELSE
  262.    BEGIN
  263.     digi_set_baud := TRUE;
  264.     digi_set_modem;
  265.    END;
  266. END;
  267.  
  268. PROCEDURE digi_flush_io;
  269. VAR
  270.  regs : REGISTERS;
  271. BEGIN;
  272.  regs.ah := $09;
  273.  regs.dx := dport_num;
  274.  INTR($14,regs);
  275. END;
  276.  
  277. PROCEDURE digi_flush_input;
  278. VAR
  279.  regs : REGISTERS;
  280. BEGIN;
  281.  regs.ah := $10;
  282.  regs.dx := dport_num;
  283.  INTR($14,regs);
  284. END;
  285.  
  286. PROCEDURE digi_flush_output;
  287. VAR
  288.  regs : REGISTERS;
  289. BEGIN;
  290.  regs.ah := $11;
  291.  regs.dx := dport_num;
  292.  INTR($14,regs);
  293. END;
  294.  
  295. PROCEDURE digi_Get_Info(VAR drivername : STRING);
  296. CONST
  297.  dname : ARRAY[1..5] OF
  298.   STRING [6] = ('COM/Xi','MC/Xi', 'PC/Xe', 'PC/Xi', 'PC/Xm' );
  299. VAR
  300.  i : BYTE;
  301.  regs : REGISTERS;
  302.  d,s,o : STRING;
  303.  versno : WORD;
  304. BEGIN;
  305.  versno := 0;
  306.  d := '';s := '';o := ' ';
  307.  WITH regs DO
  308.   BEGIN
  309.     ah := $06;
  310.     al := $ff;
  311.     dx := dport_num;
  312.   END;
  313.  INTR($14,regs);
  314.  nameptr := PTR(regs.es,regs.bx);
  315.  i := 1;
  316.  WHILE (i < 8) AND (nameptr^[i] <> #0)  DO
  317.    INC(i);
  318.  MOVE(nameptr^, d[1], i);
  319.  d[0] := CHAR(i);
  320.  
  321.  WITH regs DO
  322.   BEGIN
  323.     ah := $06;
  324.     al := $01;
  325.     dx := dport_num;
  326.   END;
  327.  INTR($14,regs);
  328.  IF regs.ah <> $ff THEN
  329.   BEGIN
  330.     versno := regs.bx;
  331.     STR(versno,o);
  332.     s := ' Version[' + o + '] : ';
  333.     STR(regs.ax,o);
  334.   END;
  335.  d := d + s;
  336.  
  337.  s := '';
  338.  
  339.  WITH regs DO
  340.   BEGIN
  341.     ah := $06;
  342.     al := $02;
  343.     bx := $000;
  344.     dx := dport_num;
  345.   END;
  346.  INTR($14,regs);
  347.  IF regs.ah <> $ff THEN
  348.    IF regs.al IN [$01..$05] THEN s := dname[regs.al]
  349.    ELSE STR(regs.al,s);
  350.  drivername := d + s + o;
  351.  
  352. END;
  353.  
  354. PROCEDURE EnableTimeOutError;
  355. VAR
  356.  regs : REGISTERS;
  357. BEGIN;
  358.  WITH regs DO
  359.   BEGIN
  360.     ah := $20;
  361.     al := $01;
  362.     dx := dport_num;
  363.   END;
  364.  INTR($14,regs);
  365. END;
  366.  
  367. PROCEDURE Digi_Break(StatusCode : WORD);  { send break }
  368. VAR
  369.  regs : REGISTERS;
  370. BEGIN;
  371.  WITH regs DO
  372.   BEGIN
  373.     ah := $07;
  374.     al := $00;       { defaults 250 millisecs }
  375.     dx := dport_num;
  376.   END;
  377.  INTR($14,regs);
  378.  AsyncStat := StatusCode;
  379. END;
  380.     
  381. END.
  382.